The Atari Compendium/The Atari Compendium (Toad Computers) (1994).iso/files/prgtools/langs/pcl-src.zoo/lucid-low.lsp

Lisp/Scheme | 1992-07-09 | 12.4 KB | 375 lines

;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox PARC
;;;   3333 Coyote Hill Rd.
;;;   Palo Alto, CA 94304
;;; (or send Arpanet mail to [e-mail])
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; This is the Lucid lisp version of the file portable-low.
;;;
;;; Lucid:               [phone]
;;;

(in-package 'pcl)

;;; First, import some necessary "internal" or Lucid-specific symbols

(eval-when (eval compile load)

(#-LCL3.0 progn #+LCL3.0 lcl:handler-bind
    #+LCL3.0 ((lcl:warning #'(lambda (condition)
                   (declare (ignore condition))
                   (lcl:muffle-warning))))
(let ((importer
        #+LCL3.0 #'sys:import-from-lucid-pkg
    #-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID")))
           (if (and x (fboundp x))
               (symbol-function x)
               ;; Only the #'(lambda (x) ...) below is really needed,
               ;;  but when available, the "internal" function
               ;;  'import-from-lucid-pkg' provides better checking.
               #'(lambda (name)
               (import (intern name "LUCID")))))))
  ;;
  ;; We need the following "internal", undocumented Lucid goodies:
  (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE"
           #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE"))

  ;;
  ;; For without-interrupts.
  ;;
  #+LCL3.0
  (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER"))

  ;;
  ;; We import the following symbols, because in 2.1 Lisps they have to be
  ;;  accessed as SYS:<foo>, whereas in 3.0 lisps, they are homed in the
  ;;  LUCID-COMMON-LISP package.
  (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*"))
  ;;
  ;; We import the following symbols, because in 2.1 Lisps they have to be
  ;;  accessed as LUCID::<foo>, whereas in 3.0 lisps, they have to be
  ;;  accessed as SYS:<foo>
  (mapc importer '(
           "NEW-STRUCTURE"       "STRUCTURE-REF"
           "STRUCTUREP"         "STRUCTURE-TYPE"  "STRUCTURE-LENGTH"
           "PROCEDUREP"         "PROCEDURE-SYMBOL"
           "PROCEDURE-REF"     "SET-PROCEDURE-REF"
           ))
; ;;
; ;;  The following is for the "patch" to the general defstruct printer.
; (mapc importer '(
;                "OUTPUT-STRUCTURE"       "DEFSTRUCT-INFO"
;           "OUTPUT-TERSE-OBJECT"  "DEFAULT-STRUCTURE-PRINT"
;           "STRUCTURE-TYPE"       "*PRINT-OUTPUT*"
;           ))
  ;;
  ;; The following is for a "patch" affecting compilation of %logand&.
  ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas
  ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS
  ;; on *FEATURES*, so this conditionalizes correctly for APOLLO.
  #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX)
  (mapc importer '("COPY-STRUCTURE"  "GET-FDESC"  "SET-FDESC"))

  nil))

;; end of eval-when

)


;;;
;;; Patch up for the fact that the PCL package creation in defsys.lisp
;;;  will probably have an explicit :use list ??
;;;
;;;  #+LCL3.0 (use-package *default-make-package-use-list*)




#+lcl4.0
(progn

(defvar *saved-compilation-speed* 3)

; the production compiler sometimes
; screws up vars within labels

(defmacro dont-use-production-compiler ()
  '(eval-when (compile)
     (setq *saved-compilation-speed* (if LUCID:*USE-SFC* 3 0))
     (proclaim '(optimize (compilation-speed 3)))))

(defmacro use-previous-compiler ()
  `(eval-when (compile)
     (proclaim '(optimize (compilation-speed ,*saved-compilation-speed*)))))

)

(defmacro %logand (x y)
  #-VAX `(%logand& ,x ,y)
  #+VAX `(logand&-variable ,x ,y))

;;; Fix for VAX LCL
#+VAX
(defun logand&-variable (x y)
  (logand&-variable x y))

;;; Fix for other LCLs
#-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX)
(eval-when (compile load eval)

(let* ((logand&-fdesc (get-fdesc 'logand&))
       (%logand&-fdesc (copy-structure logand&-fdesc)))
  (setf (structure-ref %logand&-fdesc 0 t) '%logand&)
  (setf (structure-ref %logand&-fdesc 7 t) nil)
  (setf (structure-ref %logand&-fdesc 8 t) nil)
  (set-fdesc '%logand& %logand&-fdesc))

(eval-when (load)
  (defun %logand& (x y) (%logand& x y)))

(eval-when (eval)
  (compile '%logand& '(lambda (x y) (%logand& x y))))

);#-(or LCL3.0 (and APOLLO DOMAIN/OS) VAX)

;;;
;;; From: JonL
;;; Date: November 28th, 1988
;;;
;;;  Here's a better attempt to do the without-interrupts macro for LCL3.0.
;;;  For the 2.1  release, maybe you should just ignore it (i.e, turn it
;;;  into a PROGN and "take your chances") since there isn't a uniform way
;;;  to do inhibition.  2.1 has interrupts, but no multiprocessing.
;;;
;;;  The best bet for protecting the cache is merely to inhibit the
;;;  scheduler, since asynchronous interrupts are only run when "scheduled".
;;;  Of course, there may be other interrupts, which can cons and which
;;;  could cause a GC; but at least they wouldn't be running PCL type code.
;;;
;;;  Note that INTERRUPTS-ON shouldn't arbitrarily enable scheduling again,
;;;  but rather simply restore it to the state outside the scope of the call
;;;  to WITHOUT-INTERRUPTS.  Note also that an explicit call to
;;;  MAYBE-CALL-SHEDULER must be done when "turning interrupts back on", if
;;;  there are any interrupts/schedulings pending; at least the test to see
;;;  if any are pending is very fast.

#+LCL3.0
(defmacro without-interrupts (&body body)
  `(macrolet ((interrupts-on  ()
        `(when (null outer-scheduling-state)
           (setq lcl:*inhibit-scheduling* nil)
           (when *scheduler-wakeup* (maybe-call-scheduler))))
          (interrupts-off ()
        '(setq lcl:*inhibit-scheduling* t)))
     (let ((outer-scheduling-state lcl:*inhibit-scheduling*))
       (prog1 (let ((lcl:*inhibit-scheduling* t)) . ,body)
          (when (and (null outer-scheduling-state) *scheduler-wakeup*)
        (maybe-call-scheduler))))))


;;; The following should override the definitions provided by lucid-low.
;;;
#+(or LCL3.0 (and APOLLO DOMAIN/OS))
(defstruct-simple-predicate  std-instance std-instance-p)


(defun set-function-name-1 (fn new-name ignore)
  (declare (ignore ignore))
  (if (not (procedurep fn))
      (error "~S is not a procedure." fn)
      (if (compiled-function-p fn)
      ;; This is one of:
      ;;   compiled-function, funcallable-instance, compiled-closure
      ;;   or a macro.
      ;; So just go ahead and set its name.
      ;; Only change the name when necessary: maybe it is read-only.
      (unless (eq new-name (procedure-ref fn procedure-symbol))
        (set-procedure-ref fn procedure-symbol new-name))
      ;; This is an interpreted function.
      ;; Seems like any number of different things can happen depending
      ;; vaguely on what release you are running.  Try to do something
      ;; reasonable.
      (let ((symbol (procedure-ref fn procedure-symbol)))
        (cond ((symbolp symbol)
           ;; In fact, this is the name of the procedure.
           ;; Just set it.
           (set-procedure-ref fn procedure-symbol new-name))
          ((and (listp symbol)
            (eq (car symbol) 'lambda))
           (setf (car symbol) 'named-lambda
             (cdr symbol) (cons new-name (cdr symbol))))
          ((eq (car symbol) 'named-lambda)
           (setf (cadr symbol) new-name))))))
  fn)

(defun function-arglist (fn)
  (arglist fn))

  ;;
;;;;;; printing-random-thing-internal
  ;;
(defun printing-random-thing-internal (thing stream)
  (format stream "~O" (%pointer thing)))


;;;
;;; 16-Feb-90 Jon L White
;;;
;;; A Patch provide specifically for the benefit of PCL, in the Lucid 3.0
;;;  release environment.  This adds type optimizers for FUNCALL so that
;;;  forms such as:
;;;
;;;     (FUNCALL (THE PROCEDURE F) ...)
;;;
;;;  and:
;;;
;;;     (LET ((F (Frobulate)))
;;;       (DECLARE (TYPE COMPILED-FUNCTION F))
;;;       (FUNCALL F ...))
;;;
;;;  will just jump directly to the procedure code, rather than waste time
;;;  trying to coerce the functional argument into a procedure.
;;;


(in-package "LUCID")


;;; (DECLARE-MACHINE-CLASS COMMON)
(set-up-compiler-target 'common)


(set-function-descriptor 'FUNCALL
  :TYPE  'LISP
  :PREDS 'NIL
  :EFFECTS 'T
  :OPTIMIZER  #'(lambda (form &optional environment)
          (declare (ignore form environment))
          (let* ((fun (second form))
             (lambdap (and (consp fun)
                       (eq (car fun) 'function)
                       (consp (second fun))
                       (memq (car (second fun))
                         '(lambda internal-lambda)))))
            (if (not lambdap)
            form
            (alphatize
              (cons (second fun) (cddr form)) environment))))
  :FUNCTIONTYPE '(function (function &rest t) (values &rest t))
  :TYPE-DISPATCH `(((PROCEDURE &REST T) (VALUES &REST T)
            ,#'(lambda (anode fun &rest args)
             (declare (ignore anode fun args))
             `(FAST-FUNCALL ,fun ,@args)))
           ((COMPILED-FUNCTION &REST T)  (VALUES &REST T)
            ,#'(lambda (anode fun &rest args)
             (declare (ignore anode fun args))
             `(FAST-FUNCALL ,fun ,@args))))
  :LAMBDALIST '(FN &REST ARGUMENTS)
  :ARGS '(1 NIL)
  :VALUES '(0 NIL)
  )

(def-compiler-macro fast-funcall (&rest args &environment env)
  (if (COMPILER-OPTION-SET-P :READ-SAFETY ENV)
      `(FUNCALL-SUBR . ,args)
      `(&FUNCALL . ,args)))



(setf (symbol-function 'funcall-subr) #'funcall)


;;; (UNDECLARE-MACHINE-CLASS)
(restore-compiler-params)


(in-package 'pcl)

(pushnew :structure-wrapper *features*)
(pushnew :structure-functions *features*)

(defvar *structure-type* nil)
(defvar *structure-length* nil)

(defun known-structure-type-p (type)
  (declare (special lucid::*defstructs*))
  (let ((s-data (gethash type lucid::*defstructs*)))
    (or (and s-data
         (eq 'structure (structure-ref s-data 1 'defstruct))) ; type - Fix this
    (and type (eq *structure-type* type)))))

(defun structure-type-included-type-name (type)
  (declare (special lucid::*defstructs*))
  (let ((s-data (gethash type lucid::*defstructs*)))
    (and s-data (structure-ref s-data 6 'defstruct)))) ; include - Fix this

(defun structure-type-slot-description-list (type)
  (declare (special lucid::*defstructs*))
  (let ((s-data (gethash type lucid::*defstructs*)))
    (if s-data
    (nthcdr (the index
                     (let ((include (structure-ref s-data 6 'defstruct)))
               (if include
                   (let ((inc-s-data (gethash include lucid::*defstructs*)))
                      (if inc-s-data
                     (length (structure-ref inc-s-data 7 'defstruct))
                     0))
                   0)))
        (map
                 'list
         #'(lambda (slotd)
             (let* ((slot-name (system:structure-ref slotd 0 'lucid::defstruct-slot))
                (position (system:structure-ref slotd 1 'lucid::defstruct-slot))
                (accessor (system:structure-ref slotd 2 'lucid::defstruct-slot))
                (read-only-p (system:structure-ref slotd 5 'lucid::defstruct-slot)))
               (list slot-name accessor
                 #'(lambda (x)
                     (system:structure-ref x position type))
                 (unless read-only-p
                   #'(lambda (v x)
                       (setf (system:structure-ref x position type)
                         v))))))
         (structure-ref s-data 7 'defstruct))) ; slots  - Fix this
    (let ((result (make-list (the index *structure-length*))))
      (dotimes (i *structure-length* result)
        (let* ((name (format nil "SLOT~D" i))
           (slot-name (intern name (or (symbol-package type) *package*)))
           (i i))
          (setf (elt result i) (list slot-name nil
                     #'(lambda (x)
                         (system:structure-ref x i type))
                     nil))))))))

(defun structure-slotd-name (slotd)
  (first slotd))

(defun structure-slotd-accessor-symbol (slotd)
  (second slotd))

(defun structure-slotd-reader-function (slotd)
  (third slotd))

(defun structure-slotd-writer-function (slotd)
  (fourth slotd))